{- This file is part of funbot.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- For byte strings
{-# LANGUAGE OverloadedStrings #-}

module FunBot.IrcHandlers
    ( handleBotMsg
    , handleJoin
    , handleMsg
    , handleAction
    , handleNickChange
    )
where

import Control.Exception (catch)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isAlphaNum, toLower)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.List (isPrefixOf, stripPrefix)
import FunBot.History (reportHistory)
import FunBot.Memos (reportMemos, reportMemosAll)
import FunBot.Types
import FunBot.UserOptions (getUserHistoryOpts)
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.IRC.Fun.Bot.Chat (sendToChannel)
import Network.IRC.Fun.Bot.State (getStateS)
import Text.HTML.TagSoup

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.UTF8 as BU
import qualified Data.HashMap.Lazy as M

helloWords :: [String]
helloWords = ["hello", "hi", "hey", "yo"]

waveWordsL :: [String]
waveWordsL = ["\\o", "\\O", "\\0"]

waveWordsR :: [String]
waveWordsR = ["o/", "O/", "0/"]

lastChars :: String
lastChars = ".!?"

isHello :: String -> Bool
isHello s =
    let s' = map toLower s
    in     null s
        || s' `elem` helloWords
        || init s' `elem` helloWords && last s' `elem` lastChars

isPing :: String -> Bool
isPing s =
    case stripPrefix "ping" $ map toLower s of
        Just []  -> True
        Just [c] -> c `elem` lastChars
        _        -> False

isThanks :: String -> Bool
isThanks s =
    let slow = map toLower s
    in  case (stripPrefix "thanks" slow, stripPrefix "thank you" slow) of
            (Nothing, Nothing) -> False
            _                  -> True

sayHello chan nick msg
    | isHello msg           = sendToChannel chan $ "Hello, " ++ nick
    | isPing msg            = sendToChannel chan $ nick ++ ", pong"
    | isThanks msg          = sendToChannel chan $ nick ++ ", you’re welcome!"
    | msg `elem` waveWordsL = sendToChannel chan $ nick ++ ": o/"
    | msg `elem` waveWordsR = sendToChannel chan $ nick ++ ": \\o"
    | otherwise             = return ()

handleBotMsg chan nick msg full = sayHello chan nick msg

handleJoin chan nick = do
    hd <- getUserHistoryOpts nick chan
    when (hdEnabled hd) $ reportHistory nick chan (hdMaxLines hd)
    reportMemos nick chan

goodHost h =
    let n = B.length h
        suffix6 = B.drop (n - 6) h
        suffix4 = B.drop 2 suffix6
        isCo = B.length suffix6 == 6 && ".co." `B.isPrefixOf` suffix6
        isCom = suffix4 == ".com"
    in  not $ isCom || isCo

findTitle page =
    let tags = parseTags page
        from = drop 1 $ dropWhile (not . isTagOpenName "title") tags
        range = takeWhile (not . isTagCloseName "title") from
        text = unwords $ words $ innerText range
    in  if null text then Nothing else Just text

sayTitle chan msg = when ("http" `isPrefixOf` msg) $ do
    manager <- liftIO $ newManager tlsManagerSettings
    let action = do
            request <- parseUrl msg
            let h = host request
            if goodHost h
                then do
                    response <- httpLbs request manager
                    let page = BU.toString $ responseBody response
                    return $ Right $ findTitle page
                else return $ Right Nothing
        handler e = return $ Left (e :: HttpException)
        getTitle = action `catch` handler
    etitle <- liftIO getTitle
    case etitle of
        Right (Just title) -> sendToChannel chan $ '“' : title ++ "”"
        _                  -> return ()

search _   ""   = Nothing
search msg pref = f msg False
    where
    skip = isAlphaNum
    pick = isAlphaNum
    f ""       _     = Nothing
    f (c:cs)   True  = f cs (skip c)
    f s@(c:cs) False =
        let next = f cs (skip c)
        in  case stripPrefix pref s of
                Nothing -> next
                Just r  ->
                    case span pick r of
                        ("", _)     -> next
                        (p,  "")    -> Just p
                        (p,  (d:_)) ->
                            if skip d
                                then next
                                else Just p

format cut s = shPrefix cut ++ s ++ " | " ++ shBefore cut ++ s ++ shAfter cut

sayTicket chan msg = do
    allCuts <- getStateS $ shortcuts . bsSettings
    let applies cut = chan `elem` shChannels cut
        cuts = M.elems $ M.filter applies allCuts
        getres cut = fmap (\ s -> (cut, s)) $ search msg (shPrefix cut)
        results = mapMaybe getres cuts
        first = listToMaybe results
    case first of
        Nothing       -> return ()
        Just (cut, s) -> sendToChannel chan $ format cut s

handleMsg chan nick msg _mention = do
    sayTitle chan msg
    sayTicket chan msg

handleAction chan nick msg _mention = do
    sayTicket chan msg

handleNickChange _old new = reportMemosAll new
